;;;;  $Id: indent.sld 121 2012-04-14 09:21:26Z alan.watson.f@gmail.com $
;;;;
;;;;  Copyright (c) Dorai Sitaram 1999-2010.
;;;;  Copyright (c) Alan Watson 2012.
;;;;
;;;; This program is licensed under version 3 of the GNU LGPL. See
;;;; http://www.gnu.org/licenses/lgpl.html.
;;;;
;;;; This library reads Scheme code from its stdin and writes an
;;;; indented version to its stdout.

(define-library (scheme-indent indent)

  (export indent
          indent-set!)

  (import (scheme base))
  (import (scheme read))
  (import (scheme write))
  (import (scheme char))
  (import (prefix (scheme-indent string) @))

  (begin
  
    (define (value i p)
      (call-with-values p (lambda x (list-ref x i))))

    (define *indents* '())

    (define (indent-ref s)
      (let ((c (assoc s *indents* string-ci=?)))
        (cond (c (cdr c))
              ((@prefix-ci? "def" s) 0)
              (else #f))))

    (define (indent-set! i name)
      (set! *indents*
            (cons (cons name i) *indents*)))

    (for-each
     (lambda (l)
       (let ((i (car l))
             (names (cdr l)))
         (for-each (lambda (name) (indent-set! i name)) names)))
     ;; named let should probably be 2
     '(
       (0
        "begin")
       (1
        "case"
        "define"
        "define-values"
        "define-library"
        "define-record-type"
        "define-syntax"
        "guard"
        "if"
        "lambda"
        "let"
        "let*"
        "let-syntax"
        "let-values"
        "let*-values"
        "letrec"
        "letrec*"
        "letrec-syntax"
        "parameterize"
        "syntax-rules"
        "unless"
        "when"
        "with-exception-handler"
        "with-input-from-file"
        "with-output-to-file")
       (2
        "do")))

    ;;;;;;;;;;;;;;;;;;;;

    (define (@next-ref* s i)
      (if (or (@end? s i)
              (@end? s (@next s i)))
        #f
        (@ref s (@next s i))))

    (define (@prev-ref* s i)
      (if (@start? s i)
        #f
        (@ref s (@prev s i))))

    (define (@next-next* s i)
      (@next* s (@next* s i)))

    ;;;;;;;;;;;;;;;;;;;;

    (define (whitespace? c)
      (or (eqv? c #\space)
          (eqv? c #\newline)))

    (define (escape? c)
      (eqv? c #\\))

    (define (trailing-comment-initiator? c)
      (eqv? c #\;))

    (define (string-initiator? c)
      (eqv? c #\"))

    (define (string-terminator? c)
      (eqv? c #\"))

    (define (nested-comment-initiator? c next-c)
      (and (eqv? c #\#) (eqv? next-c #\|)))

    (define (nested-comment-terminator? c next-c)
      (and (eqv? c #\|) (eqv? next-c #\#)))

    (define (vertical-bar-symbol-initiator? c)
      (eqv? c #\|))

    (define (vertical-bar-symbol-terminator? c)
      (eqv? c #\|))

    (define (open-parenthesis? c)
      (eqv? c #\())

    (define (close-parenthesis? c)
      (eqv? c #\)))

    (define (delimiter? c)
      (or (whitespace? c)
          (eqv? c #\()
          (eqv? c #\))
          (eqv? c #\")
          (eqv? c #\;)
          (eqv? c #\|)))

    (define (quote-abbreviation? c)
      (eqv? c #\'))

    (define (quasiquote-abbreviation? c)
      (eqv? c #\`))

    (define (unquote-abbreviation? c)
      (eqv? c #\,))

    (define (unquote-splicing-abbreviation? c next-c)
      (and (eqv? c #\,) (eqv? next-c #\@)))

    (define (datum-comment-initiator? c next-c)
      (and (eqv? c #\#) (eqv? next-c #\;)))

    ;;;;;;;;;;;;;;;;;;;;

    (define (skip-string line i continuing?)
      (let ((j (if continuing?
                 i
                 (@next* line i))))
        (let loop ((j j))
          (let ((c (@ref* line j)))
            (cond
             ((not c)
              j)
             ((string-terminator? c)
              (@next* line j))
             ((escape? c)
              (loop (@next-next* line j)))
             (else
              (loop (@next* line j))))))))

    (define (skip-vertical-bar-symbol line i continuing?)
      (let ((j (if continuing?
                 i
                 (@next* line i))))
        (let loop ((j j))
          (let ((c (@ref* line j)))
            (cond
             ((not c)
              j)
             ((vertical-bar-symbol-terminator? c)
              (@next* line j))
             ((escape? c)
              (loop (@next-next* line j)))
             (else
              (loop (@next* line j))))))))

    (define (skip-whitespace line i)
      (@skip line whitespace? i))

    (define (skip-trailing-comment line i)
      (@find line #\newline i))

    (define (skip-nested-comment line i level)
      (let loop ((j i) (level level))
        (let ((c (@ref* line j)))
          (cond
           ((not c)
            (values j level))
           ((nested-comment-initiator? c (@next-ref* line j))
            (loop (@next-next* line j) (+ level 1)))
           ((nested-comment-terminator? c (@next-ref* line j))
            (if (= 1 level)
              (values (@next-next* line j) 0)
              (loop (@next-next* line j) (- level 1))))
           (else
            (loop (@next* line j) level))))))

    (define (skip-word line i)
      (let loop ((j i))
        (let ((c (@ref* line j)))
          (cond
           ((or (not c) (delimiter? c))
            j)
           ((escape? c)
            (loop (@next-next* line j)))
           (else
            (loop (@next* line j)))))))

    (define (skip-token line i)
      (let ((c (@ref* line i)))
        (cond
         ((string-initiator? c)
          (skip-string line i #f))
         ((vertical-bar-symbol-initiator? c)
          (skip-vertical-bar-symbol line i #f))
         ((unquote-splicing-abbreviation? c (@next-ref* line i))
          (@next-next* line i))
         ((or (quote-abbreviation? c)
              (quasiquote-abbreviation? c)
              (unquote-abbreviation? c)
              (open-parenthesis? c)
              (close-parenthesis? c))
          (@next line i))
         (else
          (skip-word line i)))))

    (define (skip-atmosphere line i)
      (let loop ((i i))
        (let ((c      (@ref*      line i))
              (next-c (@next-ref* line i)))
          (cond
           ((not c)
            i)
           ((whitespace? c)
            (loop (skip-whitespace line i)))
           ((trailing-comment-initiator? c)
            (loop (skip-trailing-comment line i)))
           ((nested-comment-initiator? c next-c)
           	(let-values (((i level) (skip-nested-comment line i 0)))
            (loop i)))
           (else
            i)))))

    ;;;;;;;;;;;;;;;;;;;;

    (define (special-token? s)
      (if (member s '("(" ")" "'" "`" "," ",@" "#;"))
        #t
        #f))

    (define (datum-token? s)
      (and (not (zero? (string-length s)))
           (let ((c (@ref s (@start s))))
             (or (eqv? c #\#)
                 (string-initiator? c)
                 (string->number s)))))

    (define (calc-subindent s i)
      (let* ((j (skip-token s i))
             (w (@substring s i j))
             (c (@ref* w (@start w)))
             (num-aligned-subforms (indent-ref w)))
        (cond
         ((or (zero? (string-length w))
              (datum-token? w)
              (special-token? w))
          (values 1 0))
         (num-aligned-subforms
          (values 2 num-aligned-subforms))
         ((@end? s (skip-atmosphere s j))
          (values 1 0))
         (else
          (values (+ (string-length w) 2) 0)))))

    (define-record-type lparen
      (make-lparen spaces-before num-aligned-subforms num-finished-subforms)
      lparen?
      (spaces-before lparen-spaces-before)
      (num-aligned-subforms lparen-num-aligned-subforms)
      (num-finished-subforms lparen-num-finished-subforms
                             set-lparen-num-finished-subforms!))

    (define (calculate-existing-indentation line)
      (@cursor->index line (@skip-left line #\space)))

    (define (calculate-indentation line state paren-stack top-level-indentation)
      (cond
       ((or (eqv? state 'in-string)
            (eqv? state 'in-vertical-bar-symbol)
            (number? state))
        0)
       ((null? paren-stack)
        (or top-level-indentation
            (calculate-existing-indentation line)))
       (else
        (let* ((lp (car paren-stack))
               (nas (lparen-num-aligned-subforms lp))
               (nfs (lparen-num-finished-subforms lp)))
          (+ (lparen-spaces-before lp)
             (if (or (zero? nfs)
                     (> nfs nas))
               0
               2))))))

    (define (maybe-indent-left line state indentation)
      (if (or (eqv? state 'in-string)
              (eqv? state 'in-vertical-bar-symbol)
              (number? state))
        line
        (string-append (make-string indentation #\space)
                       (@trim-left line #\space))))

    (define (maybe-trim-right line state)
      (if (or (eqv? state 'in-string)
              (eqv? state 'in-vertical-bar-symbol)
              (number? state))
        line
        (string-append (@trim-right line whitespace?) "\n")))

    (define (update-finished-subforms! paren-stack)
      (when (pair? paren-stack)
        (let ((nfs (lparen-num-finished-subforms (car paren-stack))))
          (set-lparen-num-finished-subforms! (car paren-stack) (+ nfs 1)))))

    (define (parse-line line state paren-stack)

      (let loop ((i           (@start line))
                 (state       state)
                 (paren-stack paren-stack)
                 (continuing? (not (eqv? state #f))))
        (cond

         ((eqv? state 'in-whitespace)
          (let ((j (skip-whitespace line i)))
            (if (@end? line j)
              (values state paren-stack)
              (loop j #f paren-stack #f))))

         ((eqv? state 'in-trailing-comment)
          (let ((j (skip-trailing-comment line i)))
            (loop j #f paren-stack #f)))

         ((number? state)
          (let-values (((j state) (skip-nested-comment line i state)))
            (if (@end? line j)
              (values state paren-stack)
              (loop j #f paren-stack #f))))

         ((eqv? state 'in-string)
          (let ((j (skip-string line i continuing?)))
            (if (@end? line j)
              (values state paren-stack)
              (loop j #f paren-stack #f))))

         ((eqv? state 'in-vertical-bar-symbol)
          (let ((j (skip-vertical-bar-symbol line i continuing?)))
            (if (@end? line j)
              (values state paren-stack)
              (loop j #f paren-stack #f))))

         ((eqv? state 'in-word)
          (let ((j (skip-word line i)))
            (if (@end? line j)
              (values state paren-stack)
              (begin
                (update-finished-subforms! paren-stack)
                (loop j #f paren-stack #f)))))

         (else
          (let ((prev-c (@prev-ref* line i))
                (c      (@ref*      line i))
                (next-c (@next-ref* line i)))
            (cond

             ((whitespace? c)
              (loop i 'in-whitespace paren-stack #f))

             ((open-parenthesis? c)
              (let*-values
                  (((left-indent num-aligned-subforms)
                    (if (or (quote-abbreviation?      prev-c)
                            (quasiquote-abbreviation? prev-c))
                      (values 1 0)
                      (calc-subindent line (@next line i)))))
                (loop (@next line i)
                      #f
                      (cons (make-lparen (+ (@cursor->index line i) left-indent)
                                         num-aligned-subforms
                                         0)
                            paren-stack)
                      #f)))

             ((close-parenthesis? c)
              (when (null? paren-stack)
                (error "unbalanced closing parenthesis."))
              (update-finished-subforms! (cdr paren-stack))
              (loop (@next line i) #f (cdr paren-stack) #f))

             ((string-initiator? c)
              (loop i 'in-string paren-stack #f))

             ((vertical-bar-symbol-initiator? c)
              (loop i 'in-vertical-bar-symbol paren-stack #f))

             ((or (unquote-splicing-abbreviation? c next-c)
                  (datum-comment-initiator?       c next-c))
              (loop (@next-next* line i) #f paren-stack #f))

             ((or (quote-abbreviation? c)
                  (quasiquote-abbreviation? c)
                  (unquote-abbreviation? c))
              (loop (@next line i) #f paren-stack #f))

             ((trailing-comment-initiator? c)
              (loop i 'in-trailing-comment paren-stack #f))

             ((nested-comment-initiator? c next-c)
              (loop i 0 paren-stack #f))

             (else
              (loop i 'in-word paren-stack #f))))))))

    (define (indent)
      (let loop ((state #f) (paren-stack '()) (top-level-indentation #f))
        (let ((line (read-line)))
          (cond
           ((string? line)
            (let*-values
                (((line) (string-append line "\n"))
                 ((indentation)  (calculate-indentation line state paren-stack
                                                        top-level-indentation))
                 ((top-level-indentation) (or top-level-indentation
                                              indentation))
                 ((line) (maybe-indent-left line state indentation))
                 ((state paren-stack) (parse-line line state paren-stack))
                 ((line) (maybe-trim-right line state)))
              (display line)
              (loop state paren-stack top-level-indentation)))
           ((eqv? state 'in-string)
            (error "unterminated string."))
           ((eqv? state 'in-vertical-bar-symbol)
            (error "unterminated vertical-bar symbol."))
           ((number? state)
            (error "unterminated nested comment."))
           ((pair? paren-stack)
            (error "unbalanced open parenthesis."))))))))
